Visual Basic Toolbox

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / forms / datawiz / dfd.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1996-04-12 | 45.4 KB | 1,353 lines

VERSION 4.00 Begin VB.Form frmDFD BorderStyle = 3 'Fixed Dialog Caption = "Data Form Wizard" ClientHeight = 6480 ClientLeft = 885 ClientTop = 630 ClientWidth = 8205 Height = 6885 Icon = "DFD.frx":0000 Left = 825 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 6480 ScaleWidth = 8205 Top = 285 Width = 8325 Begin VB.Frame fraStep Caption = " Recordsource " Height = 3750 Index = 2 Left = 1080 TabIndex = 6 Top = 1200 Width = 6750 Begin VB.ListBox lstSQL Height = 1620 Left = 2040 TabIndex = 45 TabStop = 0 'False Top = 1920 Width = 4335 End Begin VB.ComboBox cboRecordSource Height = 315 Left = 2040 TabIndex = 7 Top = 1320 Width = 4335 End Begin VB.Label lblSQL Caption = "Field list reference for Select statement" Height = 975 Left = 840 TabIndex = 46 Top = 1920 Width = 1095 WordWrap = -1 'True End Begin VB.Label Label4 Caption = "2" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 400 size = 24 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 495 Left = 600 TabIndex = 29 Top = 360 Width = 375 End Begin VB.Line Line1 BorderWidth = 3 X1 = 360 X2 = 6360 Y1 = 1080 Y2 = 1080 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = "RecordSource: " Height = 195 Index = 6 Left = 840 TabIndex = 9 Top = 1440 Width = 1125 End Begin VB.Label lblLabels Alignment = 2 'Center Caption = "Select a Table/QueryDef from the list or enter a SQL statement.." ForeColor = &H00FF0000& Height = 495 Index = 4 Left = 1320 TabIndex = 8 Top = 480 Width = 2445 End End Begin VB.Frame fraStep Caption = " Database " Height = 3750 Index = 1 Left = 720 TabIndex = 1 Top = 1320 Width = 6750 Begin VB.CommandButton cmdOpenDB Caption = "&Open Database..." Height = 375 Left = 2040 TabIndex = 32 Top = 2160 Width = 1935 End Begin VB.ComboBox cboConnect Height = 315 ItemData = "DFD.frx":030A Left = 2040 List = "DFD.frx":032C TabIndex = 2 Top = 1440 Width = 4335 End Begin VB.Label Label3 Caption = "1." BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 400 size = 24 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 375 Left = 360 TabIndex = 34 Top = 360 Width = 615 End Begin VB.Label Label2 Caption = "Provide a database name and connect string." ForeColor = &H00FF0000& Height = 375 Left = 960 TabIndex = 33 Top = 480 Width = 1935 End Begin MSComDlg.CommonDialog dlgDBOpen Left = 6000 Top = 2040 _Version = 65536 _ExtentX = 847 _ExtentY = 847 _StockProps = 0 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = "Database Name: " Height = 195 Index = 1 Left = 480 TabIndex = 5 Top = 2160 Width = 1245 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = "Connect String: " Height = 195 Index = 2 Left = 480 TabIndex = 4 Top = 1500 Width = 1140 End Begin VB.Label lblDatabaseName ForeColor = &H00FF0000& Height = 255 Left = 1800 TabIndex = 3 Top = 3015 Width = 4470 WordWrap = -1 'True End End Begin VB.CommandButton cmdCancel Caption = "&Cancel" Height = 375 Left = 5280 TabIndex = 43 Top = 5520 Width = 1455 End Begin VB.CommandButton cmdMove Caption = "<< &Previous" Height = 375 Index = 1 Left = 240 TabIndex = 42 Top = 5520 Width = 1335 End Begin VB.CommandButton cmdMove Caption = "&Next >>" Height = 375 Index = 0 Left = 1680 TabIndex = 41 Top = 5520 Width = 1335 End Begin VB.Frame fraStep Caption = "Form info " Height = 3750 Index = 5 Left = 3360 TabIndex = 25 Top = 1560 Width = 6750 Begin VB.CheckBox chkOnScreen Caption = "On Screen" Height = 210 Left = 240 TabIndex = 44 Top = 3240 Value = 1 'Checked Width = 1875 End Begin VB.TextBox txtFormName Height = 285 Left = 3615 MaxLength = 8 TabIndex = 30 Top = 2760 Width = 1095 End Begin VB.CheckBox chkLineUnder Caption = "Line Under Headline" Height = 255 Left = 1080 TabIndex = 27 Top = 2040 Width = 2415 End Begin VB.TextBox txtHeadline Height = 285 Left = 1080 TabIndex = 26 Top = 1560 Width = 2775 End Begin VB.Label Label7 Caption = "5" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 400 size = 24 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 495 Left = 360 TabIndex = 40 Top = 240 Width = 375 End Begin VB.Label lblLabels Alignment = 2 'Center Caption = "Select a caption for the top of form and a formname." ForeColor = &H00FF0000& Height = 495 Index = 9 Left = 960 TabIndex = 39 Top = 480 Width = 2445 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = "Base Form Name (w/o Extension): " Height = 195 Index = 0 Left = 960 TabIndex = 31 Top = 2760 Width = 2460 End Begin VB.Label Label1 Caption = "Headline" Height = 255 Left = 1080 TabIndex = 28 Top = 1200 Width = 1215 End End Begin VB.Frame fraStep Caption = " Appearance " Height = 3750 Index = 4 Left = 1560 TabIndex = 21 Top = 1320 Width = 6750 Begin VB.OptionButton optLook Caption = "3D" Height = 255 Index = 0 Left = 2640 TabIndex = 24 Top = 1320 Width = 855 End Begin VB.OptionButton optLook Caption = "2D" Height = 255 Index = 1 Left = 2640 TabIndex = 23 Top = 1680 Width = 855 End Begin VB.OptionButton optLook Caption = "View " Height = 255 Index = 2 Left = 2640 TabIndex = 22 Top = 2040 Width = 855 End Begin VB.Label Label6 Caption = "4" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 400 size = 24 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 495 Left = 720 TabIndex = 38 Top = 240 Width = 375 End Begin VB.Label lblLabels Alignment = 2 'Center Caption = "Select a look for the controls you create" ForeColor = &H00FF0000& Height = 495 Index = 8 Left = 1440 TabIndex = 37 Top = 360 Width = 2445 End End Begin VB.Frame fraStep Caption = " Fields to include " Height = 3750 Index = 3 Left = 2400 TabIndex = 10 Top = 120 Width = 6750 Begin VB.ListBox lstFields DragIcon = "DFD.frx":039B Height = 1620 Left = 480 MultiSelect = 2 'Extended TabIndex = 17 Top = 1200 Width = 2535 End Begin VB.ListBox lstIncludedFields DragIcon = "DFD.frx":06A5 Height = 1620 Left = 3720 MultiSelect = 2 'Extended TabIndex = 16 Top = 1200 Width = 2655 End Begin VB.CommandButton cmdMoveFields Caption = ">>" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 375 Index = 0 Left = 3120 TabIndex = 15 Top = 1200 Width = 495 End Begin VB.CommandButton cmdMoveFields Caption = ">" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 375 Index = 1 Left = 3120 TabIndex = 14 Top = 1680 Width = 495 End Begin VB.CommandButton cmdMoveFields Caption = "<" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 375 Index = 2 Left = 3120 TabIndex = 13 Top = 2160 Width = 495 End Begin VB.CommandButton cmdMoveFields Caption = "<<" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 375 Index = 3 Left = 3120 TabIndex = 12 Top = 2640 Width = 495 End Begin VB.ListBox lstOLECtls BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 450 Left = 480 TabIndex = 11 Top = 2760 Visible = 0 'False Width = 615 End Begin VB.Label Label5 Caption = "3" BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 400 size = 24 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 495 Left = 480 TabIndex = 36 Top = 240 Width = 375 End Begin VB.Label lblLabels Alignment = 2 'Center Caption = "Select fields and field order." ForeColor = &H00FF0000& Height = 255 Index = 5 Left = 1320 TabIndex = 35 Top = 360 Width = 2445 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = " Drag/Drop to Change Order " ForeColor = &H00FF0000& Height = 195 Index = 7 Left = 1440 TabIndex = 20 Top = 600 Width = 2070 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = "Available Columns: " Height = 195 Index = 3 Left = 480 TabIndex = 19 Top = 960 Width = 1380 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = "Included Columns: " Height = 195 Index = 10 Left = 3720 TabIndex = 18 Top = 960 Width = 1350 End End Begin VB.CommandButton cmdFinish Caption = "&Build the Form" Enabled = 0 'False Height = 375 Left = 3720 TabIndex = 0 Top = 5520 Width = 1455 End Attribute VB_Name = "frmDFD" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim mdbCurrentDB As Database Dim msDBName As String Dim mrecRS As Recordset Dim mnDataType As Integer 'set in the look panel Public iScreenStyle As Integer 'constants used for the data type of the database Const gnDT_NONE = -1 Const gnDT_ACCESS = 0 Const gnDT_DBASEIV = 1 Const gnDT_DBASEIII = 2 Const gnDT_FOXPRO26 = 3 Const gnDT_FOXPRO25 = 4 Const gnDT_FOXPRO20 = 5 Const gnDT_PARADOX4X = 6 Const gnDT_PARADOX3X = 7 Const gnDT_BTRIEVE = 8 Const gnDT_ODBC = 9 'dealing with screen types Const Screen_3d = 0 Const Screen_2d = 1 Const Screen_View = 2 Private Sub cboConnect_Change() msDBName = "" mnDataType = gnDT_NONE lblDatabaseName.Caption = msDBName cboRecordSource.Clear Set mrecRS = Nothing lstFields.Clear lstIncludedFields.Clear End Sub Private Sub cboConnect_Click() Call cboConnect_Change mnDataType = cboConnect.ListIndex End Sub Private Sub cboRecordSource_Change() Set mrecRS = Nothing lstFields.Clear lstIncludedFields.Clear End Sub Private Sub cboRecordSource_Click() Call cboRecordSource_LostFocus End Sub Private Sub cboRecordSource_LostFocus() On Error GoTo RSErr Dim i As Integer Dim fld As Field If Len(cboRecordSource.Text) = 0 Then Exit Sub Screen.MousePointer = 11 'this code clears out the current field list 'and gets the new fields from the new recordset If mrecRS Is Nothing Then Set mrecRS = mdbCurrentDB.OpenRecordset(cboRecordSource.Text) For Each fld In mrecRS.Fields lstFields.AddItem fld.Name Next ElseIf mrecRS.Name <> cboRecordSource.Text Then lstFields.Clear lstIncludedFields.Clear Set mrecRS = mdbCurrentDB.OpenRecordset(cboRecordSource.Text) For Each fld In mrecRS.Fields lstFields.AddItem fld.Name Next End If Screen.MousePointer = 0 Exit Sub RSErr: Screen.MousePointer = 0 MsgBox Err.Description Exit Sub End Sub Private Sub cmdCancel_Click() Unload Me 'and do nothing else End Sub Private Sub cmdFinish_Click() If Len(txtFormName.Text) = 0 Then MsgBox "Form Name cannot be blank!", 16 txtFormName.SetFocus Exit Sub End If If InStr(txtFormName.Text, " ") > 0 Then MsgBox "Form Name cannot have spaces in it!", 16 txtFormName.SetFocus Exit Sub End If If mdbCurrentDB Is Nothing Then MsgBox "You must open a Database!", 16 Exit Sub End If If Len(cboRecordSource.Text) = 0 Then MsgBox "You must enter a RecordSource!", 16 Exit Sub End If If lstIncludedFields.ListCount = 0 Then MsgBox "You must include some Columns!", 16 Exit Sub End If Screen.MousePointer = vbHourglass If chkOnScreen.Value = vbChecked Then BuildFormOnScreen Else 'BuildFormFile 'we dont do this in this version End If Screen.MousePointer = vbDefault MsgBox "The Data Form Wizard by:" & _ vbCrLf & "Gervase Gallant (email: ggallant@gnn.com)" & _ vbCrLf & "from the Data Form Designer source code.", 48, "Wizard" Unload Me End Sub Private Sub cmdMove_Click(Index As Integer) Const Step_previous = 1 Const Step_next = 0 Static ThisIndex As Integer 'start at 1, not step 0 If ThisIndex = 0 Then ThisIndex = 1 Select Case Index Case Step_previous ThisIndex = ThisIndex - 1 fraStep(ThisIndex).ZOrder 0 If ThisIndex = 1 Then cmdMove(Index).Enabled = False Else cmdMove(1).Enabled = True cmdMove(0).Enabled = True End If Case Step_next ThisIndex = ThisIndex + 1 fraStep(ThisIndex).ZOrder 0 If ThisIndex = 5 Then cmdMove(Index).Enabled = False Else cmdMove(0).Enabled = True cmdMove(1).Enabled = True End If End Select 'when to enable the Finish button If ThisIndex = 5 Then cmdFinish.Enabled = True cmdFinish.Enabled = False End If End Sub Private Sub cmdMoveFields_Click(Index As Integer) Dim i As Integer Select Case Index Case 0 For i = 0 To lstFields.ListCount - 1 lstIncludedFields.AddItem lstFields.List(i) Next lstFields.Clear Case 1 If lstFields.ListIndex = -1 Then Exit Sub For i = lstFields.ListCount - 1 To 0 Step -1 If lstFields.Selected(i) = True Then lstIncludedFields.AddItem lstFields.List(i) lstFields.RemoveItem i End If Next Case 2 If lstIncludedFields.ListIndex = -1 Then Exit Sub For i = lstIncludedFields.ListCount - 1 To 0 Step -1 If lstIncludedFields.Selected(i) = True Then lstFields.AddItem lstIncludedFields.List(i) lstIncludedFields.RemoveItem i End If Next Case 3 For i = 0 To lstIncludedFields.ListCount - 1 lstFields.AddItem lstIncludedFields.List(i) Next lstIncludedFields.Clear End Select End Sub Private Sub cmdSQL_Click() 'added by Gervase End Sub Sub Form_Load() Dim i As Integer Me.Height = 4750 Me.Width = fraStep(1).Width + 350 'center it on the screen Me.Top = (Screen.Height - Me.Height) \ 2 Me.Left = (Screen.Width - Me.Width) \ 2 #If Win32 Then chkOnScreen.Value = vbChecked chkOnScreen.Visible = False #End If cboConnect.ListIndex = 0 'position the frames For i = 1 To 5 fraStep(i).Top = 100 fraStep(i).Left = 100 'move first frame to top fraStep(1).ZOrder 0 'position the buttons For i = 0 To 1 cmdMove(i).Top = fraStep(1).Top + fraStep(1).Height + 100 cmdFinish.Top = fraStep(1).Top + fraStep(1).Height + 100 cmdCancel.Top = fraStep(1).Top + fraStep(1).Height + 100 End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next Dim rsTmp As Recordset 'close all open recordsets For Each rsTmp In mdbCurrentDB.Recordsets rsTmp.Close Next 'close the database mdbCurrentDB.Close End Sub Sub lstIncludedFields_DragDrop(Source As Control, X As Single, Y As Single) Dim sTmp As String Dim nPos As Integer If Source = lstIncludedFields Then If lstIncludedFields.ListIndex >= 0 Then sTmp = lstIncludedFields.List(lstIncludedFields.ListIndex) nPos = (Y / TextHeight(sTmp)) + lstIncludedFields.TopIndex 'check for the last item If nPos > lstIncludedFields.ListCount Then nPos = lstIncludedFields.ListCount End If lstIncludedFields.AddItem sTmp, nPos If lstIncludedFields.ListIndex > nPos Then lstIncludedFields.RemoveItem lstIncludedFields.ListIndex + 1 Else lstIncludedFields.RemoveItem lstIncludedFields.ListIndex End If End If Source.MousePointer = 0 End If End Sub Private Sub cmdOpenDB_Click() On Error GoTo OpenError Dim sConnect As String Dim sDatabaseName As String Dim tdf As TableDef Dim qdf As QueryDef Dim fld As Field Select Case mnDataType Case gnDT_ACCESS dlgDBOpen.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*" dlgDBOpen.DialogTitle = "Open MS Access Database" Case gnDT_BTRIEVE dlgDBOpen.Filter = "Btrieve DBs (FILE.DDF)|FILE.DDF" dlgDBOpen.DialogTitle = "Open Btrieve Database" Case gnDT_DBASEIII dlgDBOpen.Filter = "dBASE III DBs (*.dbf)|*.dbf" dlgDBOpen.DialogTitle = "Open dBASE III Database" Case gnDT_DBASEIV dlgDBOpen.Filter = "dBASE IV DBs (*.dbf)|*.dbf" dlgDBOpen.DialogTitle = "Open dBASE IV Database" Case gnDT_FOXPRO20 dlgDBOpen.Filter = "FoxPro DBs (*.dbf)|*.dbf" dlgDBOpen.DialogTitle = "Open FoxPro 2.0 Database" Case gnDT_FOXPRO25 dlgDBOpen.Filter = "FoxPro DBs (*.dbf)|*.dbf" dlgDBOpen.DialogTitle = "Open FoxPro 2.5 Database" Case gnDT_FOXPRO26 dlgDBOpen.Filter = "FoxPro DBs (*.dbf)|*.dbf" dlgDBOpen.DialogTitle = "Open FoxPro 2.6 Database" Case gnDT_PARADOX3X dlgDBOpen.Filter = "Paradox DBs (*.db)|*.db" dlgDBOpen.DialogTitle = "Open Paradox 3.X Database" Case gnDT_PARADOX4X dlgDBOpen.Filter = "Paradox DBs (*.db)|*.db" dlgDBOpen.DialogTitle = "Open Paradox 4.X Database" Case Else If UCase(Left(cboConnect.Text, 4)) = "ODBC" Then 'default to ODBC mnDataType = gnDT_ODBC Else Beep MsgBox "Invalid Connect String!", 48 Exit Sub End If End Select If mnDataType <> gnDT_ODBC Then With dlgDBOpen .FilterIndex = 1 .FileName = msDBName '"" .CancelError = True .Flags = &H4 .Action = 1 End With msDBName = dlgDBOpen.FileName Else msDBName = "" End If lblDatabaseName.Caption = msDBName cboRecordSource.Clear lstSQL.Clear Set mrecRS = Nothing lstFields.Clear lstIncludedFields.Clear Me.Refresh 'repaint the form to get rid og the common dialog Select Case mnDataType Case gnDT_ACCESS sConnect = "" sDatabaseName = msDBName Case gnDT_DBASEIII sConnect = "dBASE III" sDatabaseName = StripFileName(msDBName) Case gnDT_DBASEIV sConnect = "dBASE IV" sDatabaseName = StripFileName(msDBName) Case gnDT_FOXPRO20 sConnect = "FoxPro 2.0" sDatabaseName = StripFileName(msDBName) Case gnDT_FOXPRO25 sConnect = "FoxPro 2.5" sDatabaseName = StripFileName(msDBName) Case gnDT_PARADOX3X sConnect = "Paradox 3.X" sDatabaseName = StripFileName(msDBName) Case gnDT_PARADOX4X sConnect = "Paradox 4.X" sDatabaseName = StripFileName(msDBName) Case gnDT_BTRIEVE sConnect = "Btrieve;" sDatabaseName = msDBName Case Else sConnect = cboConnect.Text sDatabaseName = msDBName End Select Screen.MousePointer = 11 'set the hourglass Set mdbCurrentDB = OpenDatabase(sDatabaseName, False, True, sConnect) 'set the connect string for an ODBC datasource If mnDataType = gnDT_ODBC Then cboConnect.Text = mdbCurrentDB.Connect End If For Each tdf In mdbCurrentDB.TableDefs If (tdf.Attributes And &H80000002) = 0 Then cboRecordSource.AddItem tdf.Name lstSQL.AddItem "TABLE: " & tdf.Name lstSQL.AddItem "------------------------" For Each fld In tdf.Fields lstSQL.AddItem tdf.Name & "." & fld.Name Next lstSQL.AddItem "------------------------" End If Next If mnDataType = gnDT_ACCESS Then For Each qdf In mdbCurrentDB.QueryDefs cboRecordSource.AddItem qdf.Name lstSQL.AddItem "QUERYDEF: " & qdf.Name lstSQL.AddItem "------------------------" For Each fld In qdf.Fields lstSQL.AddItem qdf.Name & "." & fld.Name Next lstSQL.AddItem "------------------------" Next End If cboRecordSource.ListIndex = 0 Screen.MousePointer = 0 'unset the hourglass Exit Sub OpenError: Screen.MousePointer = 0 'unset the hourglass If Err <> 32755 Then 'check for common dialog cancelled MsgBox Err.Description End If Exit Sub End Sub Private Sub lstIncludedFields_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then lstIncludedFields.Drag End Sub Sub BuildFormOnScreen() On Error GoTo BuildErr Dim i As Integer, iThis As Integer, iAddtoTop As Integer Dim sTmp As String Dim nNumFlds As Integer Dim frmNewForm As vbide.FormTemplate Dim nButtonTop As Integer Dim iHiddenLeft As Integer Dim iFieldHeight As Integer 'just how many fields do you want to display?? Const MAX_Fields = 50 Const QB_RED = 12 'assign height of fields Select Case iScreenStyle Case Screen_3d iFieldHeight = 320 'standard height of 3d fields Case Screen_2d iFieldHeight = 285 '2d height Case Screen_View iFieldHeight = 225 'view only (transparent, borderless...) End Select 'deal with too many fields If lstIncludedFields.ListCount > MAX_Fields Then MsgBox "You have requested" & Str$(lstIncludedFields.ListCount) & _ ". However, only" & Str$(MAX_Fields) & " can be displayed.", _ vbExclamation, App.Title nNumFlds = MAX_Fields Else nNumFlds = lstIncludedFields.ListCount End If lstOLECtls.Clear 'create the new form Set frmNewForm = gobjIDEAppInst.ActiveProject.AddFormTemplate() 'make room for the headline and line If txtHeadline.Text = "" Then iAddtoTop = 0 iAddtoTop = 700 End If 'form height = iFieldHeight * numflds + 1260 for buttons and data control 'form width = 5640 With frmNewForm.Properties .Item("Caption") = Left(mrecRS.Name, 32) .Item("Height") = 1115 + (nNumFlds * iFieldHeight) + iAddtoTop .Item("Name") = "frm" & txtFormName.Text .Item("Width") = 5640 .Item("Left") = 1050 End With iHiddenLeft = -5640 'add headline to top If txtHeadline.Text <> "" Then With frmNewForm.ControlTemplates.Add("label").Properties .Item("Name") = "lblHeadline" .Item("left") = 120 .Item("top") = 50 .Item("caption") = txtHeadline.Text .Item("autosize") = True .Item("forecolor") = QBColor(QB_RED) '************************************* 'AAARGH!!!!!! 'ATTEMPTS BELOW: all of these failed '.Item("font").Properties("bold").Value = 0 '.Item("font(0)") = True '.Item("font(3)") = 24 '.item("font.size") = 24 'YOU CAN actually nest like this at runtime 'but not here 'with .item("font") '.Item("bold") = True 'end with '******************************************* End With '*********************************************************************** ' since the headline was the first control I made, I was able to reference it ' as the first element of the ControlTemplates collection, which spared me 'from having to loop through the collection to find my headline frmNewForm.ControlTemplates(0).Properties("font").Value("bold").Value = False frmNewForm.ControlTemplates(0).Properties("font").Value("size").Value = 24 If chkLineUnder.Value Then With frmNewForm.ControlTemplates.Add("line").Properties .Item("x1") = 120 .Item("Y1") = iAddtoTop - 50 .Item("x2") = 5640 - 240 .Item("y2") = iAddtoTop - 50 .Item("Name") = "lineHeadline" .Item("BorderWidth") = 1 .Item("bordercolor") = QBColor(12) End With End If End If 'labels.left") = 120, .width") = 1815, .height = 255 'fields.left = 2040, .width = 3375, .height = 285 For i = 0 To nNumFlds - 1 sTmp = lstIncludedFields.List(i) With frmNewForm.ControlTemplates.Add("Label").Properties .Item("Left") = iHiddenLeft .Item("Caption") = sTmp & ":" .Item("Height") = 255 .Item("Index") = i .Item("Name") = "lblLabels" .Item("Top") = (i * iFieldHeight) + 60 + iAddtoTop .Item("Width") = 1815 .Item("Left") = 120 End With If mrecRS.Fields(sTmp).Type = 1 Then 'true/false field With frmNewForm.ControlTemplates.Add("CheckBox").Properties .Item("Left") = iHiddenLeft .Item("Caption") = "" .Item("Height") = 285 .Item("Index") = i .Item("Name") = "chkFields" .Item("Top") = (i * iFieldHeight) + 40 + iAddtoTop .Item("Width") = 3375 .Item("DataSource") = "Data1" .Item("DataField") = sTmp .Item("Left") = 2040 End With ElseIf mrecRS.Fields(sTmp).Type = 11 Then 'picture field With frmNewForm.ControlTemplates.Add("OLE").Properties .Item("Left") = iHiddenLeft .Item("Height") = 285 .Item("Name") = "oleField" & i .Item("OLETypeAllowed") = 1 .Item("Top") = (i * iFieldHeight) + 40 + iAddtoTop .Item("Width") = 3375 .Item("DataSource") = "Data1" .Item("DataField") = sTmp .Item("Left") = 2040 End With SendKeys "{Esc}" lstOLECtls.AddItem i Else With frmNewForm.ControlTemplates.Add("TextBox").Properties .Item("Left") = iHiddenLeft .Item("Index") = i .Item("Name") = "txtFields" .Item("Text") = "" If mrecRS.Fields(sTmp).Type < 10 Then 'numeric or date .Item("Width") = 1935 Else 'string or memo .Item("Width") = 3375 End If .Item("DataSource") = "Data1" .Item("DataField") = sTmp If mrecRS.Fields(sTmp).Type = 10 Then .Item("Height") = 285 .Item("Top") = (i * iFieldHeight) + 40 + iAddtoTop .Item("MaxLength") = mrecRS.Fields(sTmp).Size ElseIf mrecRS.Fields(sTmp).Type = 12 Then .Item("Height") = 310 .Item("Top") = (i * iFieldHeight) + 30 + iAddtoTop .Item("MultiLine") = True .Item("ScrollBars") = 2 Else .Item("Height") = 285 .Item("Top") = (i * iFieldHeight) + 40 + iAddtoTop End If .Item("Left") = 2040 '************************************** 'APPEARANCE: how you switch from 3d to 2d to Flat Select Case iScreenStyle Case Screen_3d 'do nothing .Item("appearance") = 1 Case Screen_2d .Item("Appearance") = 0 Case Screen_View .Item("Appearance") = 0 .Item("backcolor") = &HE0E0E0 'grey it out?? .Item("borderstyle") = 0 .Item("Locked") = True End Select '******************************************************* End With End If Next nButtonTop = i * iFieldHeight + 120 'still can't figure why an extra 120! 'add the data control and buttons With frmNewForm.ControlTemplates.Add("Data").Properties .Item("Left") = iHiddenLeft .Item("Caption") = "" .Item("DatabaseName") = mdbCurrentDB.Name .Item("Connect") = mdbCurrentDB.Connect .Item("RecordSource") = cboRecordSource.Text .Item("Align") = 2 'toolbar type End With '******************************************************* 'if screen is View then don't add, delete,update,refresh If iScreenStyle <> Screen_View Then With frmNewForm.ControlTemplates.Add("CommandButton").Properties .Item("Left") = iHiddenLeft .Item("Caption") = "&Add" .Item("Height") = 300 .Item("Name") = "cmdAdd" .Item("Top") = nButtonTop + iAddtoTop .Item("Width") = 975 .Item("Left") = 120 End With With frmNewForm.ControlTemplates.Add("CommandButton").Properties .Item("Left") = iHiddenLeft .Item("Caption") = "&Delete" .Item("Height") = 300 .Item("Name") = "cmdDelete" .Item("Top") = nButtonTop + iAddtoTop .Item("Width") = 975 .Item("Left") = 1200 End With With frmNewForm.ControlTemplates.Add("CommandButton").Properties .Item("Left") = iHiddenLeft .Item("Caption") = "&Refresh" .Item("Height") = 300 .Item("Name") = "cmdRefresh" .Item("Top") = nButtonTop + iAddtoTop .Item("Width") = 975 .Item("Left") = 2280 End With With frmNewForm.ControlTemplates.Add("CommandButton").Properties .Item("Left") = iHiddenLeft .Item("Caption") = "&Update" .Item("Height") = 300 .Item("Name") = "cmdUpdate" .Item("Top") = nButtonTop + iAddtoTop .Item("Width") = 975 .Item("Left") = 3360 End With End If With frmNewForm.ControlTemplates.Add("CommandButton").Properties .Item("Left") = iHiddenLeft .Item("Caption") = "&Close" .Item("Height") = 300 .Item("Name") = "cmdClose" .Item("Top") = nButtonTop + iAddtoTop .Item("Width") = 975 .Item("Left") = 4440 End With 'add the code to the form Dim fh As Integer fh = FreeFile Open App.Path & "\DFD_FRM.MOD" For Output As fh WriteFrmCode fh Close fh frmNewForm.InsertFile App.Path & "\DFD_FRM.MOD" Kill App.Path & "\DFD_FRM.MOD" 'save the new form gobjIDEAppInst.ActiveProject.SelectedComponents(0).SaveAs (gobjIDEAppInst.LastUsedPath & "\" & txtFormName & ".FRM") 'set the form back to defaults txtFormName.Text = "" cboRecordSource.Text = "" 'try to set focus back to the form Me.SetFocus txtFormName.SetFocus Exit Sub BuildErr: MsgBox Err.Description Resume Next End Sub Sub BuildFormFile() On Error GoTo BuildFErr Dim i As Integer Dim sTmp As String Dim nNumFlds As Integer Dim frmNewForm As Object Dim ctlNewControl As Object Dim nButtonTop As Integer 'create and open the file Dim nFileHnd As Integer nFileHnd = FreeFile Open gobjIDEAppInst.LastUsedPath & "\" & txtFormName & ".FRM" For Output As nFileHnd Print #nFileHnd, "VERSION 4.00" nNumFlds = lstIncludedFields.ListCount lstOLECtls.Clear Print #nFileHnd, "Begin VB.Form frm" & txtFormName.Text 'form height = 320 * numflds + 1260 for buttons and data control 'form width = 5640 Print #nFileHnd, " Caption = """ & Left(mrecRS.Name, 32) & """" Print #nFileHnd, " Height = " & 1115 + (nNumFlds * 320) Print #nFileHnd, " Left = 2400" Print #nFileHnd, " Top = 2040" Print #nFileHnd, " Width = 5640" 'labels.left = 120, .width = 1815, .height = 255 'fields.left = 2040, .width = 3375, .height = 285 For i = 0 To nNumFlds - 1 sTmp = lstIncludedFields.List(i) Print #nFileHnd, " Begin VB.Label lblLabels" Print #nFileHnd, " Caption = """ & sTmp & ":""" Print #nFileHnd, " Height = 255" Print #nFileHnd, " Index = " & i Print #nFileHnd, " Left = 120" Print #nFileHnd, " Top = " & (i * 320) + 60 Print #nFileHnd, " Width = 1815" Print #nFileHnd, " End" If mrecRS.Fields(sTmp).Type = 1 Then 'true/false field Print #nFileHnd, " Begin VB.CheckBox chkField" & i Print #nFileHnd, " DataField = """ & sTmp & """" Print #nFileHnd, " DataSource = ""Data1""" Print #nFileHnd, " Height = 285" Print #nFileHnd, " Index = " & i Print #nFileHnd, " Left = 2040" Print #nFileHnd, " Top = " & (i * 320) + 40 Print #nFileHnd, " Width = 3375" Print #nFileHnd, " End" ElseIf mrecRS.Fields(sTmp).Type = 11 Then 'picture field Print #nFileHnd, " Begin VB.OLE oleField" & i Print #nFileHnd, " DataField = """ & sTmp & """" Print #nFileHnd, " DataSource = ""Data1""" Print #nFileHnd, " Height = 285" Print #nFileHnd, " Left = 2040" Print #nFileHnd, " OLETypeAllowed = 1" Print #nFileHnd, " Top = " & (i * 320) + 40 Print #nFileHnd, " Width = 3375" Print #nFileHnd, " End" lstOLECtls.AddItem i Else Print #nFileHnd, " Begin VB.TextBox txtField" & i Print #nFileHnd, " DataField = """ & sTmp & """" Print #nFileHnd, " DataSource = ""Data1""" If mrecRS.Fields(sTmp).Type = 12 Then Print #nFileHnd, " Height = 310" Else Print #nFileHnd, " Height = 285" End If Print #nFileHnd, " Index = " & i Print #nFileHnd, " Left = 2040" If mrecRS.Fields(sTmp).Type = 10 Then Print #nFileHnd, " MaxLength = " & mrecRS.Fields(sTmp).Size End If If mrecRS.Fields(sTmp).Type = 12 Then Print #nFileHnd, " MultiLine = True" End If If mrecRS.Fields(sTmp).Type = 12 Then Print #nFileHnd, " ScrollBars = 2" End If Print #nFileHnd, " Top = " & (i * 320) + 40 Print #nFileHnd, " Text = """"" If mrecRS.Fields(sTmp).Type < 10 Then 'numeric or date Print #nFileHnd, " Width = 1935" Else 'string or memo Print #nFileHnd, " Width = 3375" End If Print #nFileHnd, " End" End If Next nButtonTop = (((i - 1) * 320) + 40) + 340 'add the data control and buttons Print #nFileHnd, " Begin VB.Data Data1" Print #nFileHnd, " Align = 2" Print #nFileHnd, " Caption = """"" Print #nFileHnd, " Connect = """ & mdbCurrentDB.Connect & """" Print #nFileHnd, " DatabaseName = """ & mdbCurrentDB.Name & """" Print #nFileHnd, " RecordSource = """ & cboRecordSource.Text & """" Print #nFileHnd, " End" Print #nFileHnd, " Begin VB.CommandButton cmdAdd" Print #nFileHnd, " Caption = ""&Add""" Print #nFileHnd, " Height = 300" Print #nFileHnd, " Left = 120" Print #nFileHnd, " Top = " & nButtonTop Print #nFileHnd, " Width = 975" Print #nFileHnd, " End" Print #nFileHnd, " Begin VB.CommandButton cmdDelete" Print #nFileHnd, " Caption = ""&Delete""" Print #nFileHnd, " Height = 300" Print #nFileHnd, " Left = 1200" Print #nFileHnd, " Top = " & nButtonTop Print #nFileHnd, " Width = 975" Print #nFileHnd, " End" Print #nFileHnd, " Begin VB.CommandButton cmdRefresh" Print #nFileHnd, " Caption = ""&Refresh""" Print #nFileHnd, " Height = 300" Print #nFileHnd, " Left = 2280" Print #nFileHnd, " Top = " & nButtonTop Print #nFileHnd, " Width = 975" Print #nFileHnd, " End" Print #nFileHnd, " Begin VB.CommandButton cmdUpdate" Print #nFileHnd, " Caption = ""&Update""" Print #nFileHnd, " Height = 300" Print #nFileHnd, " Left = 3360" Print #nFileHnd, " Top = " & nButtonTop Print #nFileHnd, " Width = 975" Print #nFileHnd, " End" Print #nFileHnd, " Begin VB.CommandButton cmdClose" Print #nFileHnd, " Caption = ""&Close""" Print #nFileHnd, " Height = 300" Print #nFileHnd, " Left = 4440" Print #nFileHnd, " Top = " & nButtonTop Print #nFileHnd, " Width = 975" Print #nFileHnd, " End" Print #nFileHnd, "End" Print #nFileHnd, "" Print #nFileHnd, "Attribute VB_Name = ""frm" & txtFormName.Text & """" Print #nFileHnd, "Attribute VB_Creatable = False" Print #nFileHnd, "Attribute VB_Exposed = False" Print #nFileHnd, "Option Explicit" Print #nFileHnd, "" 'add the code to the form WriteFrmCode nFileHnd Close nFileHnd 'add the new form to the project gobjIDEAppInst.ActiveProject.AddFile gobjIDEAppInst.LastUsedPath & "\" & txtFormName & ".FRM" 'set the form back to defaults txtFormName.Text = "" cboRecordSource.Text = "" 'try to set focus back to the form Me.SetFocus txtFormName.SetFocus Exit Sub BuildFErr: MsgBox Err.Description Exit Sub End Sub Private Sub lstSQL_Click() End Sub Private Sub optLook_Click(Index As Integer) iScreenStyle = Index End Sub